{*******************************************************************************
* The contents of this file are used with permission, subject to the Mozilla   *
* Public License Version 1.1 (the "License"); you may not use this file except *
* in compliance with the License. You may obtain a copy of the License at      *
* http://www.mozilla.org/MPL/                                                  *
*                                                                              *
* Software distributed under the License is distributed on an "AS IS" basis,   *
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for *
* the specific language governing rights and limitations under the License.    *
*                                                                              *
* The Original Code is distributed as part of the "mediate" product and is     *
* Copyright (C) @home media limited. All Rights Reserved.                      *
*                                                                              *
* Email: support@athomemedia.co.uk                                             *
* Web:   http://www.athomemedia.co.uk                                          *
*******************************************************************************}

unit Expressions;

interface

uses Classes, UIObjects, Formula, XMLHelper, AHMTypes;

const
{$IFDEF DESIGNER}
  MODIFY_CAPTION = 'Edit Expression';

  // Property categories and hints for designer
  CAT_EXPRESSION = 'Expression';
  HINT_CALCULATION = 'defines the calculation logic for this expression';
{$ENDIF}

  CUSTOM_FN_META = 'META';
  CUSTOM_FN_META_EMPTY = 'EMPTY';

  CUSTOM_FN_LANG = 'LANG';
  CUSTOM_FN_EXPR = 'EXPR';

type
  TAHMFormula = class(TArtFormula)
  private
    FMetaModule: PTableItem;
    FInitialised: Boolean;
    FParsingError: Boolean;
    FErrorMessage: String;
    procedure SetExpression(Expression: String);
  protected
    property Initialised: Boolean read FInitialised;
    property ParsingError: Boolean read FParsingError;
    property Expression: String write SetExpression;
    property ErrorMessage: String read FErrorMessage;
    procedure Clear;
  public
    constructor Create;
    destructor Destroy; override;
  end;

  TAHMExpression = class(TAHMUIObject)
  private
    FFormula: TAHMFormula;
    FExpression: TAHMMemoString;
  protected
    procedure SetExpression(Expression: TAHMMemoString);
    procedure ClearProperties; override;
  public
    constructor Create(const Name: String); override;
    destructor Destroy; override;
    function Evaluate: String;
    function EvaluateBool: Boolean;
    function RenderPreview: Boolean; override;
    function ModifyActions: Integer; override;
    function Modify(Action: Integer): Boolean; override;
    function ModifyCaption(Action: Integer): String; override;
    procedure SeedObject; override;
    procedure Assign(Source: TPersistent); override;
    procedure SaveAsXML(Lines: TStrings); override;
    procedure ParseFromXML(XML: TAHMXMLHelper); override;
    procedure BuildProperties(Properties: TAHMUIPropertyList); override;
  published
    property Expression: TAHMMemoString read FExpression write SetExpression;
  end;

  TAHMExpressionList = class(TAHMUIObjectList)
  private
  protected
  public
    constructor Create; override;
    function AddExpression(const InheritFrom, NewName: String): TAHMExpression;
    function GetExpression(const Name: String): TAHMExpression;
  end;


implementation

uses SysUtils, StrUtils, TagNames, ApplicationManager, Screen, MetaData,
     Languages, {$IFDEF DESIGNER}DesignerTextEdit,{$ENDIF} Logging, XMLTags;


//TAHMFormula helper functions

function TAHMFormula_LanguageFn(var Calc: TFormulaCalc): TCalcItem;
begin
  // Set language string result with top stack item passed as name parameter
  setS(Result, LanguageManagerInstance.Translate(Calc.TopS));
end;

function TAHMFormula_MetaDataFn(var Calc: TFormulaCalc): TCalcItem;
begin
  // Set meta string result with top stack item passed as name parameter
  setS(Result, ApplicationManagerInstance.MetaDataManager.GetMetaValue(Calc.TopS));
end;

function TAHMFormula_MetaDataEmptyFn(var Calc: TFormulaCalc): TCalcItem;
var
  Value: String;
begin
  // Set boolean result with top stack item passed as name parameter
  Value := ApplicationManagerInstance.MetaDataManager.GetMetaValue(Calc.TopS);
  if Value = '' then setN(Result, 1) else setN(Result, 0);
end;

function TAHMFormula_ExpressionFn(var Calc: TFormulaCalc): TCalcItem;
begin
  // Set expression string result with top stack item passed as name parameter
  setS(Result, ApplicationManagerInstance.ExpressionManager.Evaluate(Calc.TopS));
end;

constructor TAHMFormula.Create;
begin
  inherited;

  // Configure formula parser properties
  CaseSensitive := False;
  UnquotedString := True;
  Step := False;

  // Add our custom functions/modules
  FMetaModule := AddUserFunction(CUSTOM_FN_META, 1, TAHMFormula_MetaDataFn, True);
  AddModuleFunction(FMetaModule, CUSTOM_FN_META_EMPTY, 1, TAHMFormula_MetaDataEmptyFn);

  AddUserFunction(CUSTOM_FN_LANG, 1, TAHMFormula_LanguageFn, False);
  AddUserFunction(CUSTOM_FN_EXPR, 1, TAHMFormula_ExpressionFn, False);
end;

destructor TAHMFormula.Destroy;
var
  i: Integer;
begin
  // Free our custom functions/modules
  for i := 0 to Length(FMetaModule.funs) - 1 do
    Dispose(FMetaModule.funs[i]);

  for i := 0 to Length(UserFunc) - 1 do
    Dispose(UserFunc[i]);

  inherited;
end;

procedure TAHMFormula.SetExpression(Expression: String);
begin
  try
    // Attempt to compile our expression
    Compile(Expression, 0, nil);
    FErrorMessage := '';
  except
    on E:FormulaException do
    begin
      // Problem with the expression - write to log
      FErrorMessage := 'Failed to parse expression - ' + E.Message + ' on line ' +
                       IntToStr(ErrLine) + ' at position ' + IntToStr(ErrPos);
      LogWarn(FErrorMessage);

      if LogDebugEnabled then
        LogDebug(Expression + sLineBreak + DupeString(' ', Pred(ErrPos)) + '^');
      FParsingError := True;
    end;
  end;

  // Either way, we've now been initialised
  FInitialised := True;
end;

procedure TAHMFormula.Clear;
begin
  FInitialised  := False;
  FParsingError := False;
end;

//----------------------------------------------------------------------------//

constructor TAHMExpression.Create(const Name: String);
begin
  inherited Create(Name);

  XMLTagName := TAG_EXPRESSION;
  ObjectType := otExpressions;
  ImageIndex := Ord(otExpressions);

  FFormula := TAHMFormula.Create;
end;

destructor TAHMExpression.Destroy;
begin
  FFormula.Free;

  inherited Destroy;
end;

procedure TAHMExpression.SetExpression(Expression: TAHMMemoString);
begin
  FExpression := Expression;
  FFormula.Clear;
end;

procedure TAHMExpression.ClearProperties;
begin
  inherited;

  // Clear custom expression properties
  SetExpression('');
end;

function TAHMExpression.Evaluate: String;
begin
  // Set default result - empty string
  Result := '';
  try
    // Compile expression on first use
    if not FFormula.Initialised then
      FFormula.Expression := FExpression;

    if FFormula.ParsingError then
    begin
      State := osError;
      Result := FFormula.ErrorMessage;
      LogDebug('Failed to evaluate expression due to previous parsing error: ' + Name);
    end
    else
    begin
      State := osValid;
      Result := FFormula.Compute(0, nil);

      // Round up floating point boolean values
      if Pos('0.999', Result) = 1 then Result := '1';
    end;
  except
    on E: Exception do
      LogWarn('String expression ' + Name + ' raised unhandled exception: ' + E.Message);
  end;
end;

function TAHMExpression.EvaluateBool: Boolean;
var
  Calc: Double;
begin
  // Set default result in case we get an exception
  Result := False;
  try
    // Use method above to compute as string then convert to double
    Result := TryStrToFloat(Evaluate, Calc);

    // If converted to double then check for 0/1 values
    if Result then Result := (Calc > 0);
  except
    on E: Exception do
      LogWarn('Boolean expression ' + Name + ' raised unhandled exception: ' + E.Message);
  end;
end;

function TAHMExpression.RenderPreview: Boolean;
begin
{$IFDEF DESIGNER}
  with ScreenInstance.Viewport do
  begin
    Canvas.DesignerBackground(ViewportRect);
    Canvas.TextRect(ViewportRect, nil, 'Expression:' + sLineBreak +
                    FExpression + sLineBreak + sLineBreak + 'Result:' +
                    sLineBreak + Evaluate);
  end;
{$ENDIF}
  Result := True;
end;

function TAHMExpression.ModifyActions: Integer;
begin
  // Supports single action to modify expression value
  Result := 1;
end;

function TAHMExpression.Modify(Action: Integer): Boolean;
begin
{$IFDEF DESIGNER}
  // Edit expression with text dialog
  Result := TfrmTextProperties.EditText(String(FExpression), 'Calculation', Self);
  if Result then DoModified;
  if Result then FFormula.Clear;
{$ELSE}
  Result := False;
{$ENDIF}
end;

function TAHMExpression.ModifyCaption(Action: Integer): String;
begin
{$IFDEF DESIGNER}
  Result := MODIFY_CAPTION;
{$ELSE}
  Result := '';
{$ENDIF}
end;

procedure TAHMExpression.SeedObject;
begin
{$IFDEF DESIGNER}
  if Ancestor = nil then Expression := '2+2';
{$ENDIF}
end;

procedure TAHMExpression.Assign(Source: TPersistent);
begin
  inherited Assign(Source);

  with Source as TAHMExpression do
  begin
    Self.Expression := Expression;
  end;
end;

procedure TAHMExpression.SaveAsXML(Lines: TStrings);
begin
  // We write expressions out on a single line
  SaveXMLComments(Lines);
  Lines.Add(TABS[XMLIndent + 2] + TagBegin + EncodeXMLValue(FExpression) + TagEnd);
end;

procedure TAHMExpression.ParseFromXML(XML: TAHMXMLHelper);
begin
  // Just parse expression text
  Expression := XML.GetValue;
end;

procedure TAHMExpression.BuildProperties(Properties: TAHMUIPropertyList);
begin
{$IFDEF DESIGNER}
  inherited;

  // Build custom expression properties
  Properties.Add('Calculation', 'Expression', CAT_EXPRESSION, HINT_CALCULATION);
{$ENDIF}
end;

//----------------------------------------------------------------------------//

constructor TAHMExpressionList.Create;
begin
  inherited Create;

  XMLTagName := TAG_GLOBAL_EXPS;
  ChildClass := TAHMExpression;
end;

function TAHMExpressionList.AddExpression(const InheritFrom, NewName: String): TAHMExpression;
begin
  Result := TAHMExpression(Inherit(InheritFrom, NewName));
end;

function TAHMExpressionList.GetExpression(const Name: String): TAHMExpression;
begin
  Result := TAHMExpression(GetObject(Name));
end;


end.
